;;; -*- Mode:LISP; Package:TV; Base:8; Readtable:ZL -*-
;;;     ** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; Superior that supports its inferiors as panes -- windows which are managed
;;; by the superior in some way

;;; Each window that is a pane (an inferior of a frame), should include
;;; the PANE-MIXIN flavor so as to interact correctly
(DEFFLAVOR PANE-MIXIN () ()
  (:INCLUDED-FLAVORS ESSENTIAL-WINDOW)
  (:DOCUMENTATION "No-op for compatibility"))

(DEFFLAVOR PANE-NO-MOUSE-SELECT-MIXIN () (DONT-SELECT-WITH-MOUSE-MIXIN)
  :ALIAS-FLAVOR)

(DEFFLAVOR WINDOW-PANE () (WINDOW)
  :ALIAS-FLAVOR)

(DEFFLAVOR LISP-LISTENER-PANE () (LISP-LISTENER)
  :ALIAS-FLAVOR)

(DEFFLAVOR COMMAND-MENU-PANE () (COMMAND-MENU)
  :ALIAS-FLAVOR)

;;; Basic frame contains methods that are used by most frames
;;; Recursion variable keeps track of whether or not we are performing an operation
;;;  that will cause us to get notified.  If RECURSION is set, the routine
;;;  should ignore the notification and return immediatly a value of T.  This
;;;  will be the standard.
(DEFFLAVOR BASIC-FRAME ((RECURSION NIL))
  (ESSENTIAL-EXPOSE ESSENTIAL-ACTIVATE ESSENTIAL-SET-EDGES POP-UP-NOTIFICATION-MIXIN
   ESSENTIAL-WINDOW)
  (:REQUIRED-METHODS :INFERIOR-SET-EDGES)
  (:DEFAULT-INIT-PLIST :BLINKER-P NIL :MORE-P NIL)
  (:DOCUMENTATION "Pane handling messages used by most frames"))

;; Obsolete name.
(DEFFLAVOR FRAME-DONT-SELECT-INFERIORS-WITH-MOUSE-MIXIN () (ALIAS-FOR-INFERIORS-MIXIN)
  (:REQUIRED-FLAVORS BASIC-FRAME)
  (:DOCUMENTATION "Don't list our panes in Select menu."))

(DEFMETHOD (FRAME-DONT-SELECT-INFERIORS-WITH-MOUSE-MIXIN :SELECTABLE-WINDOWS) (&AUX STRING)
  (AND (SETQ STRING (SEND SELF ':NAME-FOR-SELECTION))
       (LIST (LIST STRING SELF))))

(DEFFLAVOR INFERIORS-NOT-IN-SELECT-MENU-MIXIN () (ALIAS-FOR-INFERIORS-MIXIN)
  (:REQUIRED-FLAVORS BASIC-FRAME)
  (:DOCUMENTATION "Don't list our panes in Select menu."))

(DEFMETHOD (INFERIORS-NOT-IN-SELECT-MENU-MIXIN :SELECTABLE-WINDOWS) (&AUX STRING)
  (AND (SETQ STRING (SEND SELF ':NAME-FOR-SELECTION))
       (LIST (LIST STRING SELF))))

(DEFMETHOD (BASIC-FRAME :SELECTED-PANE) () SELECTION-SUBSTITUTE)

;This sets what pane should be selected if this window is selected.
(DEFMETHOD (BASIC-FRAME :SELECT-PANE) (PANE)
  (OR (MEMQ PANE INFERIORS)
      (NULL PANE)
      (FERROR "Cannot select ~S, which is not a pane of ~S" PANE SELF))
  (SEND SELF :SET-SELECTION-SUBSTITUTE PANE))

(DEFMETHOD (BASIC-FRAME :NAME-FOR-SELECTION) ()
  (AND SELECTION-SUBSTITUTE (SEND SELECTION-SUBSTITUTE :NAME-FOR-SELECTION)))

;;This is a bad way to do things, and will get flushed
;;once the system is verified to work without it.
(DEFCONST FLUSH-BASIC-FRAME-STATUS-METHOD NIL)
(DEFWRAPPER (BASIC-FRAME :STATUS) (IGNORE . BODY)
  `(COND ((AND SELECTION-SUBSTITUTE
               (NOT FLUSH-BASIC-FRAME-STATUS-METHOD)
               (EQ (SEND SELECTION-SUBSTITUTE :STATUS) ':SELECTED))
          ':SELECTED)
         (T . ,BODY)))

(DEFMETHOD (BASIC-FRAME :AFTER :ACTIVATE) (&REST IGNORE)
  (DOLIST (I INFERIORS)
    ;; Give it a chance to put itself in previously-selected-windows.
    (SEND I ':ACTIVATE)))

(DEFMETHOD (BASIC-FRAME :AFTER :DEACTIVATE) (&REST IGNORE)
  ;; Make sure that none of our inferiors are remembered as selectable
  (DOLIST (I INFERIORS)
    (REMOVE-FROM-PREVIOUSLY-SELECTED-WINDOWS I)))

(DEFWRAPPER (BASIC-FRAME :PRINT-NOTIFICATION) (ARGS . BODY)
  `(IF SELECTION-SUBSTITUTE
       (LEXPR-SEND SELECTION-SUBSTITUTE :PRINT-NOTIFICATION ARGS)
       . ,BODY))

;; Removing this should make nested frames win more.
;(DEFMETHOD (BASIC-FRAME :ALIAS-FOR-SELECTED-WINDOWS) () SELF)

(DEFMETHOD (BASIC-FRAME :INFERIOR-SELECT) (PANE)
  (SETQ SELECTION-SUBSTITUTE PANE)
  T)

;;; Screen management et. al.
(DEFMETHOD (BASIC-FRAME :SCREEN-MANAGE-RESTORE-AREA) (RECTS ARRAY-TO-DRAW-ON X Y ALU &AUX RS)
  (IF BIT-ARRAY
      (SCREEN-MANAGE-RESTORE-AREA RECTS ARRAY-TO-DRAW-ON X Y ALU T)
      (DOLIST (R RECTS)
        (COND ((EQ (CAR (RECT-SOURCE R)) SELF)
               (PUSH (LIST (LIST SELF 0 0)
                           (- (RECT-LEFT R) X-OFFSET) (- (RECT-TOP R) Y-OFFSET)
                           (- (RECT-RIGHT R) X-OFFSET) (- (RECT-BOTTOM R) Y-OFFSET))
                     RS)
               (SETQ RECTS (DELQ R RECTS)))))
      (SCREEN-MANAGE-SHEET SELF RS ARRAY-TO-DRAW-ON (+ X X-OFFSET) (+ Y Y-OFFSET) ALU)
      RECTS))

;; I think these are no longer relevant.
;(DEFWRAPPER (BASIC-FRAME :EXPOSE) (IGNORE . BODY)
;  `(LETF ((RECURSION T))
;     . ,BODY))

;(DEFWRAPPER (BASIC-FRAME :DEEXPOSE) (IGNORE . BODY)
;  `(LETF ((RECURSION T))
;     . ,BODY))

(DEFMETHOD (BASIC-FRAME :SCREEN-MANAGE-DEEXPOSED-VISIBILITY) () T)

(DEFMETHOD (BASIC-FRAME :SCREEN-MANAGE-UNCOVERED-AREA) SCREEN-MANAGE-CLEAR-UNCOVERED-AREA)


(DEFFLAVOR FRAME-FORWARDING-MIXIN () ()
  (:INCLUDED-FLAVORS BASIC-FRAME)
  (:DOCUMENTATION "Used when forwarding of EXPOSE//DEEXPOSE//BURY messages from pane
to frame is desired."))

(DEFMETHOD (FRAME-FORWARDING-MIXIN :INFERIOR-EXPOSE) (PANE)
  PANE
  (COND (RECURSION T)
        (T (SEND SELF ':EXPOSE)
           NIL)))

(DEFMETHOD (FRAME-FORWARDING-MIXIN :INFERIOR-DEEXPOSE) (PANE)
  PANE
  (COND (RECURSION T)
        (T (SEND SELF ':DEEXPOSE)
           NIL)))

(DEFMETHOD (FRAME-FORWARDING-MIXIN :INFERIOR-BURY) (PANE)
  PANE
  (COND (RECURSION T)
        (T (SEND SELF ':BURY)
           NIL)))

(DEFMETHOD (FRAME-FORWARDING-MIXIN :INFERIOR-SET-EDGES) (PANE &REST ARGS)
  (IF RECURSION
      T
    (LETF ((RECURSION T))
      ;; :SET-EDGES can deexpose and reexpose the pane;
      ;; avoid forwarding that to the frame.
      (LEXPR-SEND PANE ':SET-EDGES ARGS))))

(DEFWRAPPER (FRAME-FORWARDING-MIXIN :SCREEN-MANAGE-AUTOEXPOSE-INFERIORS) (IGNORE . BODY)
  `(LETF ((RECURSION T))
     . ,BODY))

(DEFMETHOD (BASIC-FRAME :PANE-TYPES-ALIST) ()
  NIL)

;;; Simple superior for split-screen
(DEFFLAVOR SPLIT-SCREEN-FRAME () (scale-inferiors-mixin BASIC-FRAME))

(DEFMETHOD (SPLIT-SCREEN-FRAME :PANE-TYPES-ALIST) ()
  DEFAULT-WINDOW-TYPES-ITEM-LIST)

(DEFMETHOD (SPLIT-SCREEN-FRAME :NAME-FOR-SELECTION) () NAME)

(DEFMETHOD (SPLIT-SCREEN-FRAME :AFTER :EXPOSE) (&REST IGNORE)
  (REMOVE-FROM-PREVIOUSLY-SELECTED-WINDOWS SELF))

(DEFMETHOD (SPLIT-SCREEN-FRAME :AFTER :ACTIVATE) (&REST IGNORE)
  (REMOVE-FROM-PREVIOUSLY-SELECTED-WINDOWS SELF))

(DEFMETHOD (SPLIT-SCREEN-FRAME :SELECT) (&REST ARGS)
  (SEND SELF ':SET-SELECTION-SUBSTITUTE (FIRST EXPOSED-INFERIORS))
  (LEXPR-SEND (FIRST EXPOSED-INFERIORS) ':SELECT ARGS))

;;; Constraint frames -- these frames maintain their panes based on a set
;;;  of constraints.  These frames are the right thing for most frame applications.

;PANES is the list describing the panes, specified by the user.
;INTERNAL-PANES is an alist mapping pane-names (as used in PANES and in constraints)
;to actual windows.
;EXPOSED-PANES is a list of panes used in the current configuration.
;CONSTRAINTS is, again, the list specified by the user.
;PARSED-CONSTRAINS is the result of crunching that.
;INTERNAL-CONSTRAINS contains the parsed constraints for this configuration.
(DEFFLAVOR BASIC-CONSTRAINT-FRAME (PANES INTERNAL-PANES SELECTION-SUBSTITUTE
                                   (EXPOSED-PANES NIL)
                                   CONSTRAINTS PARSED-CONSTRAINTS INTERNAL-CONSTRAINTS
                                   (SUBSTITUTIONS NIL)
                                   (BLANK-RECTANGLES NIL)
                                   (CONFIGURATION NIL))
           (BASIC-FRAME)
  (:INITABLE-INSTANCE-VARIABLES CONSTRAINTS PANES SUBSTITUTIONS SELECTION-SUBSTITUTE CONFIGURATION)
  (:GETTABLE-INSTANCE-VARIABLES CONSTRAINTS PANES CONFIGURATION)
  (:SETTABLE-INSTANCE-VARIABLES EXPOSED-PANES)
  (:DOCUMENTATION "Maintains panes according to specified constraints"))


;There used to be a definition of the :inferior-set-edges operation here.
;Let's see if there is any problem with this being the same as FRAME-FORWARDING-MIXIN
;before flushing the separate name.
(DEFFLAVOR CONSTRAINT-FRAME-FORWARDING-MIXIN () (FRAME-FORWARDING-MIXIN))

(DEFFLAVOR CONSTRAINT-FRAME-NO-FORWARDING () (BASIC-CONSTRAINT-FRAME BASIC-FRAME)
  (:DOCUMENTATION "Constraint frame, but with no special handling of FORWARDed
messages such as :EXPOSE."))

(DEFFLAVOR CONSTRAINT-FRAME ()
           (BASIC-CONSTRAINT-FRAME CONSTRAINT-FRAME-FORWARDING-MIXIN BASIC-FRAME)
  (:DOCUMENTATION "Normal constraint frame"))

(DEFFLAVOR BORDERED-CONSTRAINT-FRAME ()
           (BASIC-CONSTRAINT-FRAME CONSTRAINT-FRAME-FORWARDING-MIXIN BORDERS-MIXIN BASIC-FRAME)
  (:DEFAULT-INIT-PLIST :BORDER-MARGIN-WIDTH 0)
  (:DOCUMENTATION "Maintains uniform borders around panes"))

(DEFSTRUCT (CONSTRAINT-NODE :ARRAY)
  CONSTRAINT-NAME                       ;Name of this node
  (CONSTRAINT-MIN -1)                   ;Minimum limit
  (CONSTRAINT-MAX 1_20.)                ;Maximum limit
  CONSTRAINT-CONSTRAINT                 ;The constraint as specified by the user
  CONSTRAINT-TYPE                       ;One of: :WINDOW, :STACKING, :IF, :BLANK
  CONSTRAINT-DATA                       ;If WINDOW: the window
                                        ;If SPECIAL: (ordering . inferiors)
                                        ;If IF: (conditional . inferiors)
                                        ;If BLANK: function to draw "whitespace"
  (CONSTRAINT-CW 0)                     ;Current position of this window (if a window)
  (CONSTRAINT-CH 0)
  (CONSTRAINT-CX 0)
  (CONSTRAINT-CY 0)
  (CONSTRAINT-PW 0)                     ;Proposed position
  (CONSTRAINT-PH 0)
  (CONSTRAINT-PX 0)
  (CONSTRAINT-PY 0))

(DEFUN CONSTRAINT-FRAME-PROCESS-CONSTRAINTS (&REST IGNORE)
  "CONSTRAINTS contains a list of unprocessed constraints.  Process them.  Entries
look like:

   constraint := ({:LIMIT (min max {[:LINES | :CHARACTERS]})}
                  [:ASK-WINDOW pane-name message . args |
                   :ASK message . args |
                   :FUNCALL function . args |
                   :EVAL form |
                   [:EVEN | fixnum | flonum] {[:LINES | :CHARACTERS]} |
                   :FIXED
                   ])

   desc := (ordering desc-part)
   desc-part := (desc-group) {desc-part}
   desc-group := [ ('window name' . constraint) |
                   ('special name' [:HORIZONTAL | :VERTICAL] constraint . desc) |
                   ('special name' :IF [conditional | :ELSE] desc)
                   ('special name' :BLANK [:WHITE | :BLACK] constraint)
                   ] {desc-group}


    Fixnum - absolute number of pixels
    Flonum - percentage of available space
    :EVEN - divide remaining space evenly among all :EVEN constraints
            :EVEN's can only be in the last descriptor group, and must be by themselves
            (No other types of constraints allowed)
    :ASK, :ASK-WINDOW, :FUNCALL - sends the message to the pane with the args as shown below,
      and the specified args, and expects back the height or
      the width that the window wants to be.  :ASK-WINDOW takes the
      name of a window as its first arg.

    :EVAL - evals the specified form

    :FIXED - Only for a window: never change the window's size

    For :FUNCALL the first arg is the node.
    For :EVAL, **CONSTRAINT-NODE** is bound to the node.

      The first five arguments given to the method are as follows:
        **CONSTRAINT-REMAINING-WIDTH** - The maximum width of the window (amount
                                         of space remaining for this window)
        **CONSTRAINT-REMAINING-HEIGHT** - The maximum height
        **CONSTRAINT-TOTAL-WIDTH** - The total width of the current section
        **CONSTRAINT-TOTAL-HEIGHT** - The total height of the current section
        **CONSTRAINT-CURRENT-STACKING** - :HORIZONTAL or :VERTICAL, depending upon
                                            which dimension is currently being hacked

      (In the case of :EVAL, these special variables are bound)

 A typical frame setup might be (dimension starts out as :HEIGHT):

 ((WA LISP-LISTENER) (WB MENU :ITEM-LIST (foo bar baz quux))
  (WC MY-OWN-LISP-LISTENER) (WD SOME-OTHER-FUNNY-WINDOW :MY-INIT MY-ARG))

 ((WA
   WB
   G0)
  ((WB :ASK :PANE-SIZE))
  ((WA :LIMIT (3 NIL :LINES) :EVEN)
   (G0 :HORIZONTAL (:ASK-WINDOW WD :PANE-SIZE)
       (WD WC)
       ((WC :LIMIT (10. NIL :LINES) :EVEN)
        (WD :LIMIT (10. NIL :LINES) :EVEN)))))"
  (DECLARE (:SELF-FLAVOR BASIC-CONSTRAINT-FRAME))
  ;; First turn constraint list into nodes
  (SETQ INTERNAL-PANES (LETF ((RECURSION T)) (CONSTRAINT-FRAME-WINDOWS PANES)))
  (SETQ PARSED-CONSTRAINTS NIL)
  (DOLIST (CONSTR CONSTRAINTS)
    (PUSH (CONS (CAR CONSTR)
                (CONSTRAINT-FRAME-PARSE-CONSTRAINTS (CDR CONSTR) INTERNAL-PANES))
          PARSED-CONSTRAINTS))
  (SETQ PARSED-CONSTRAINTS (NREVERSE PARSED-CONSTRAINTS)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :AFTER :INIT) (IGNORE)
  (CONSTRAINT-FRAME-PROCESS-CONSTRAINTS)
  (SETF `(,CONFIGURATION . ,INTERNAL-CONSTRAINTS)
        (IF CONFIGURATION
            (OR (ASSQ CONFIGURATION PARSED-CONSTRAINTS)
                (FERROR "Configuration ~S not found" CONFIGURATION))
            (FIRST PARSED-CONSTRAINTS)))        ;Default initial configuration
  (AND SELECTION-SUBSTITUTE
       (SYMBOLP SELECTION-SUBSTITUTE)
       (SETQ SELECTION-SUBSTITUTE (SEND SELF ':GET-PANE SELECTION-SUBSTITUTE)))
  (CONSTRAINT-FRAME-RECOMPUTE-CONFIGURATION))

(DEFUN CONSTRAINT-FRAME-DRAW-BLANK-SPACE (&OPTIONAL (CONSTRS INTERNAL-CONSTRAINTS))
  "Map over the constraint data structure, and draw all blank area."
  (DECLARE (:SELF-FLAVOR BASIC-CONSTRAINT-FRAME))
  (DOLIST (AENTRY (FIRST CONSTRS))
    (LET ((NODE (CDR AENTRY)))
      (CASE (CONSTRAINT-TYPE NODE)
        (:BLANK (PREPARE-SHEET (SELF)
                  (CONSTRAINT-FRAME-DRAW-A-BLANK (CONSTRAINT-DATA NODE) NODE
                                                 (CONSTRAINT-CX NODE) (CONSTRAINT-CY NODE)
                                                 (CONSTRAINT-CW NODE) (CONSTRAINT-CH NODE)
                                                 SCREEN-ARRAY)))
        (:STACKING (CONSTRAINT-FRAME-DRAW-BLANK-SPACE (CONSTRAINT-DATA NODE)))))))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :AFTER :REFRESH) (&OPTIONAL TYPE)
  (OR (AND RESTORED-BITS-P (NEQ TYPE ':SIZE-CHANGED))
      (EQ TYPE ':MARGINS-ONLY)
      (CONSTRAINT-FRAME-DRAW-BLANK-SPACE)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :AFTER :CHANGE-OF-DEFAULT-FONT) (OLD-FONT NEW-FONT)
  ;; SHEET'S method got the INFERIORS -- get any panes that weren't got then.
  (DOLIST (ELT INTERNAL-PANES)
    (LET ((PANE (CDR ELT)))
      (OR (MEMQ PANE INFERIORS)
          (NOT (TYPEP PANE 'INSTANCE))
          (SEND PANE :CHANGE-OF-DEFAULT-FONT OLD-FONT NEW-FONT)))))

;;; Stuff for dealing with panes by name

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :GET-PANE) (PANE-NAME)
  "Returns the pane with specified name or NIL if not found"
  (CDR (ASSQ PANE-NAME INTERNAL-PANES)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :SEND-PANE) (PANE-NAME MESSAGE &REST ARGS &AUX W)
  "Send a message to the pane with specified name (error if not found)"
  (IF (SETQ W (CDR (ASSQ PANE-NAME INTERNAL-PANES)))
      (LEXPR-SEND W MESSAGE ARGS)
      (FERROR "No pane named ~S in this frame" PANE-NAME)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :SEND-ALL-PANES) (MESSAGE &REST ARGS)
  "Send a message to all panes, including non-exposed ones"
  (DOLIST (X INTERNAL-PANES)
    (LEXPR-SEND (CDR X) MESSAGE ARGS)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :SEND-ALL-EXPOSED-PANES) (MESSAGE &REST ARGS)
  "Send a message to all exposed panes"
  (DOLIST (X INTERNAL-PANES)
    (AND (MEMQ (CDR X) EXPOSED-INFERIORS)
         (LEXPR-SEND (CDR X) MESSAGE ARGS))))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :PANE-NAME) (PANE)
  "Given a pane, this returns the name for that pane the user gave in his alist.
   NIL if for some reason it is not found."
  (DOLIST (X INTERNAL-PANES)
    (AND (EQ (CDR X) PANE) (RETURN (CAR X)))))


(DEFMETHOD (BASIC-CONSTRAINT-FRAME :GET-CONFIGURATION) (CONFIG-NAME)
  (CDR (ASSQ CONFIG-NAME PARSED-CONSTRAINTS)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :REDEFINE-CONFIGURATION) (CONFIG-NAME NEW-CONFIG
                                                             &OPTIONAL (PARSED-P T))
  (OR PARSED-P (SETQ NEW-CONFIG
                     (CONSTRAINT-FRAME-PARSE-CONSTRAINTS NEW-CONFIG INTERNAL-PANES)))
  (LET ((CONFIG (ASSQ CONFIG-NAME PARSED-CONSTRAINTS)))
    (WITHOUT-INTERRUPTS
      (OR CONFIG
          (IF PARSED-CONSTRAINTS
              (RPLACD (LAST PARSED-CONSTRAINTS) (SETQ CONFIG (CONS CONFIG-NAME NIL)))
              (SETQ PARSED-CONSTRAINTS (SETQ CONFIG (CONS CONFIG-NAME NIL))))))
    (RPLACD CONFIG NEW-CONFIG)
    NEW-CONFIG))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :SET-CONFIGURATION) (NEW-CONFIG-NAME)
  (LET ((CONFIG (ASSQ NEW-CONFIG-NAME PARSED-CONSTRAINTS)))
    (OR CONFIG (FERROR "Unknown configuration ~A" NEW-CONFIG-NAME))
    (SETQ CONFIGURATION (CAR CONFIG)
          INTERNAL-CONSTRAINTS (CDR CONFIG)
          BLANK-RECTANGLES NIL))
  (CONSTRAINT-FRAME-CLEAR-CURRENT-POSITION INTERNAL-CONSTRAINTS)
  (CONSTRAINT-FRAME-RECOMPUTE-CONFIGURATION))

(DEFUN CONSTRAINT-FRAME-CLEAR-CURRENT-POSITION (CONSTRS &AUX NODE)
  (DOLIST (AENTRY (FIRST CONSTRS))
    (SETQ NODE (CDR AENTRY))
    (CASE (CONSTRAINT-TYPE NODE)
      (:WINDOW
       (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
           (SEND (CONSTRAINT-DATA NODE) :EDGES)
         (SETF (CONSTRAINT-CX NODE) LEFT)
         (SETF (CONSTRAINT-CY NODE) TOP)
         (SETF (CONSTRAINT-CW NODE) (- RIGHT LEFT))
         (SETF (CONSTRAINT-CH NODE) (- BOTTOM TOP))))
      (:STACKING
       (CONSTRAINT-FRAME-CLEAR-CURRENT-POSITION (CONSTRAINT-DATA NODE)))
      (:IF (FERROR ":IF node type not yet implemented"))
      (OTHERWISE
       (SETF (CONSTRAINT-CX NODE) 0)
       (SETF (CONSTRAINT-CY NODE) 0)
       (SETF (CONSTRAINT-CW NODE) 0)
       (SETF (CONSTRAINT-CH NODE) 0)))))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :VERIFY-NEW-EDGES) (IGNORE IGNORE NEW-WIDTH NEW-HEIGHT)
  (COND ((VARIABLE-BOUNDP INTERNAL-CONSTRAINTS)
         (IF (NOT (CONSTRAINT-FRAME-DO-CONSTRAINTS SELF INTERNAL-CONSTRAINTS
                                          (- NEW-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)
                                          (- NEW-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE)))
             "Some constraint cannot be satisfied"
             ;; Change our size temporarily
             ;; so that panes will check their edges against the new size
             (WITHOUT-INTERRUPTS
               (LETF ((WIDTH NEW-WIDTH) (HEIGHT NEW-HEIGHT) (RECURSION T))
                 (COND ((CONSTRAINT-FRAME-SET-EDGES INTERNAL-CONSTRAINTS ':VERIFY) NIL)
                       (T "Some pane refused to have its size set"))))))))

(DEFUN CONSTRAINT-FRAME-RECOMPUTE-CONFIGURATION ()
  (DECLARE (:SELF-FLAVOR BASIC-CONSTRAINT-FRAME))
  (PRESERVE-SUBSTITUTE-STATUS SELF
    (LETF ((RECURSION T))
      (SEND SELF :DEEXPOSE :DEFAULT :NOOP)
      (DOLIST (P EXPOSED-PANES)
        (SEND P :DEEXPOSE :DEFAULT :NOOP)
        ;; This assures that old panes won't gratuitously reappear if there is
        ;; blank space in the new configuration where a pane used to be.  Note that
        ;; this is careful not to touch inferiors that aren't "panes" of this
        ;; constraint frame.
        (SEND P :DEACTIVATE))
      (OR (CONSTRAINT-FRAME-DO-CONSTRAINTS SELF INTERNAL-CONSTRAINTS
                                           (SHEET-INSIDE-WIDTH) (SHEET-INSIDE-HEIGHT))
          (FERROR "Some constraint could not be satisfied"))
      (CONSTRAINT-FRAME-SET-EDGES INTERNAL-CONSTRAINTS NIL)
      (DOLIST (P EXPOSED-PANES) (SEND P :EXPOSE))
      (SETQ BLANK-RECTANGLES NIL)
      (SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
        (CONSTRAINT-FRAME-DRAW-BLANK-SPACE))
      (OR (MEMQ SELECTION-SUBSTITUTE EXPOSED-INFERIORS)
          (SETQ SELECTION-SUBSTITUTE NIL)))))

;;; When the inside-size changes, rethink the constraints and panes' edges
(DEFMETHOD (BASIC-CONSTRAINT-FRAME :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE)
  (CONSTRAINT-FRAME-RECOMPUTE-CONFIGURATION))

(DEFUN CONSTRAINT-FRAME-SCREEN-MANAGE-UNCOVERED-AREA (RECTS ARRAY X Y IGNORE)
  "If there is any blank area, it might be covered by some :BLANK type constraints.
Check through the constraint list, and draw onto the array the appropriate swatches
of 'blankness'"
  (DECLARE (:SELF-FLAVOR BASIC-CONSTRAINT-FRAME))
  (OR BLANK-RECTANGLES
      ;; If haven't figured out the blank rectangles, compute them now
      (SETQ BLANK-RECTANGLES
            (OR (CONSTRAINT-FRAME-MAKE-BLANK-RECTANGLES INTERNAL-CONSTRAINTS)
                T)))
  (AND (NEQ BLANK-RECTANGLES T)
       (DOLIST (R RECTS)
         (COND ((EQ (CAR (RECT-SOURCE R)) SELF)
                ;; This is a blank area, hack appropriate portions of it
                (PROG DONE ((REMAINING-BLANK-RECTS (LIST R)))
                  (DOLIST (BLANK-RECT BLANK-RECTANGLES)
                    (DOLIST (REM-BLANK-RECT REMAINING-BLANK-RECTS)
                      (COND ((RECT-NOT-OVERLAP-RECT-P BLANK-RECT REM-BLANK-RECT))
                            (T
                             (LET ((NODE (FOURTH (RECT-SOURCE BLANK-RECT)))
                                   (LEFT) (TOP) (RIGHT) (BOTTOM))
                               ;; Draw the overlapping area
                               (SETQ LEFT (MAX (RECT-LEFT BLANK-RECT)
                                               (RECT-LEFT REM-BLANK-RECT))
                                     TOP (MAX (RECT-TOP BLANK-RECT) (RECT-TOP REM-BLANK-RECT))
                                     RIGHT (MIN (RECT-RIGHT BLANK-RECT)
                                                (RECT-RIGHT REM-BLANK-RECT))
                                     BOTTOM (MIN (RECT-BOTTOM BLANK-RECT)
                                                 (RECT-BOTTOM REM-BLANK-RECT)))
                               (CONSTRAINT-FRAME-DRAW-A-BLANK
                                 (CONSTRAINT-DATA NODE) NODE
                                 (+ X LEFT) (+ Y TOP) (- RIGHT LEFT) (- BOTTOM TOP)
                                 ARRAY))
                             (SETQ REMAINING-BLANK-RECTS
                                   (NCONC (RECTANGLE-NOT-INTERSECTION BLANK-RECT
                                                                      REM-BLANK-RECT)
                                          (DELQ REM-BLANK-RECT REMAINING-BLANK-RECTS)))
                             (AND (NULL REMAINING-BLANK-RECTS) (RETURN-FROM DONE))))))
                  (SETQ RECTS (NCONC REMAINING-BLANK-RECTS RECTS)))
                (SETQ RECTS (DELQ R RECTS 1))))))
  RECTS)

(DEFWRAPPER (BASIC-CONSTRAINT-FRAME :SCREEN-MANAGE-UNCOVERED-AREA) ((RECTS ARRAY X Y ALU)
                                                                     . BODY)
  `(PROGN (SETF (SECOND SI::.DAEMON-CALLER-ARGS.)
                (CONSTRAINT-FRAME-SCREEN-MANAGE-UNCOVERED-AREA RECTS ARRAY X Y ALU))
          . ,BODY))

(DEFUN CONSTRAINT-FRAME-MAKE-BLANK-RECTANGLES (CONSTR &AUX RECTS)
  (DOLIST (AENTRY (FIRST CONSTR))
    (LET ((NODE (CDR AENTRY))
          (X) (Y))
      (CASE (CONSTRAINT-TYPE NODE)
        (:BLANK (PUSH (LIST (LIST SELF 0 0 NODE)
                            (SETQ X (CONSTRAINT-CX NODE)) (SETQ Y (CONSTRAINT-CY NODE))
                            (+ X (CONSTRAINT-CW NODE)) (+ Y (CONSTRAINT-CH NODE)))
                      RECTS))
        (:STACKING
         (SETQ RECTS
               (NCONC RECTS
                      (CONSTRAINT-FRAME-MAKE-BLANK-RECTANGLES (CONSTRAINT-DATA NODE))))))))
  RECTS)

(DEFVAR CONSTRAINT-FRAME-DEFAULT-STACKING ':VERTICAL)

(DEFUN CONSTRAINT-FRAME-SET-EDGES (CONSTRS OPTION &AUX X Y R)
  "Loop over all panes and hack the edges as specified by the option."
  (NOT
    (DOLIST (AENTRY (FIRST CONSTRS))
      (LET ((NODE (CDR AENTRY)))
        (CASE (CONSTRAINT-TYPE NODE)
          (:WINDOW
           (SETQ R (OR (AND (NEQ OPTION ':VERIFY)
                            (= (CONSTRAINT-PX NODE) (CONSTRAINT-CX NODE))
                            (= (CONSTRAINT-PY NODE) (CONSTRAINT-CY NODE))
                            (= (CONSTRAINT-PW NODE) (CONSTRAINT-CW NODE))
                            (= (CONSTRAINT-PH NODE) (CONSTRAINT-CH NODE)))
                       (SEND (CONSTRAINT-DATA NODE)
                             :SET-EDGES (SETQ X (CONSTRAINT-PX NODE))
                                        (SETQ Y (CONSTRAINT-PY NODE))
                                        (+ X (CONSTRAINT-PW NODE))
                                        (+ Y (CONSTRAINT-PH NODE))
                                        OPTION))))
          (:STACKING (SETQ R (CONSTRAINT-FRAME-SET-EDGES (CONSTRAINT-DATA NODE) OPTION)))
          (:IF (FERROR ":IF is unimplemented option"))
          (OTHERWISE (SETQ R T)))
        (IF (EQ OPTION ':VERIFY)

            ;; If verifying, return right away if didn't verify
            (OR R (RETURN T))

            ;; If not verifying, proposed data is now current data
            (SETF (CONSTRAINT-CX NODE) (CONSTRAINT-PX NODE))
            (SETF (CONSTRAINT-CY NODE) (CONSTRAINT-PY NODE))
            (SETF (CONSTRAINT-CW NODE) (CONSTRAINT-PW NODE))
            (SETF (CONSTRAINT-CH NODE) (CONSTRAINT-PH NODE)))))))

(DEFUN CONSTRAINT-FRAME-WINDOWS (DESCS &AUX PARSED)
  (DOLIST (DESC DESCS)
    (PUSH (CONS (FIRST DESC)
                (IF (TYPEP (CDR DESC) 'SHEET)
                    (CDR DESC)
                    (LEXPR-SEND SELF ':CREATE-PANE DESC)))
          PARSED))
  PARSED)

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :CREATE-PANE) (IGNORE FLAVOR &REST OPTIONS)
  (APPLY #'MAKE-INSTANCE FLAVOR :SUPERIOR SELF OPTIONS))

(DEFFLAVOR CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER ((IO-BUFFER NIL)) (BASIC-CONSTRAINT-FRAME)
  (:INITABLE-INSTANCE-VARIABLES IO-BUFFER)
  (:GETTABLE-INSTANCE-VARIABLES IO-BUFFER))

(DEFMETHOD (CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER :BEFORE :INIT) (IGNORE)
  (OR IO-BUFFER (SETQ IO-BUFFER (MAKE-DEFAULT-IO-BUFFER))))

(DEFMETHOD (CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER :CREATE-PANE) (IGNORE FLAVOR &REST OPTIONS)
  (APPLY #'MAKE-INSTANCE FLAVOR :SUPERIOR SELF :IO-BUFFER IO-BUFFER OPTIONS))

(DEFFLAVOR BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER ()
  (CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER CONSTRAINT-FRAME-FORWARDING-MIXIN
   BORDERS-MIXIN BASIC-FRAME)
  (:DEFAULT-INIT-PLIST :BORDER-MARGIN-WIDTH 0))

(DEFUN CONSTRAINT-FRAME-SUBSTITUTION (DESC)
  (DECLARE (:SELF-FLAVOR BASIC-CONSTRAINT-FRAME))
  (COND ((CONSP DESC) DESC)
        ((SYMBOLP DESC)
         (OR (CDR (ASSQ DESC SUBSTITUTIONS))
             (FERROR "~A is a symbol where a list was expected (and it has no substitution)"
                     DESC)))
        (T (FERROR "~A was found where a list (or a symbol with a substitution) was expected"
                   DESC))))

(DEFUN CONSTRAINT-FRAME-PARSE-CONSTRAINTS (CONSTRAINTS PANES
                                            &OPTIONAL (STACKING
                                                        CONSTRAINT-FRAME-DEFAULT-STACKING))
  "Given a list of constraints, returns the internal format."
  (LET ((INTERNAL-ORDERING NIL)
        (ORDERING (CAR CONSTRAINTS))
        (INTERNAL-DESCS NIL))
    (OR (CONSP ORDERING)
        (FERROR "Constraint ~S does not start with an ordering" CONSTRAINTS))
    (DO ((WNS ORDERING (CDR WNS))
         (WS NIL)
         (WINDOW))
        ((NULL WNS)
         (SETQ INTERNAL-ORDERING (NREVERSE WS)))
      (PUSH (CONS (CAR WNS)
                  (IF (SETQ WINDOW (ASSQ (CAR WNS) PANES))
                      (CDR WINDOW)              ;A window, include the window itself
                      (CAR WNS)))               ;Must be a special name, will fill it in later
            WS))
    (DO ((DESC-GROUPS (CDR CONSTRAINTS) (CDR DESC-GROUPS))
         (INTERNAL-DESC-GROUP NIL NIL)
         (EVEN-P NIL NIL)
         (LAST-GROUP-P))
        ((NULL DESC-GROUPS))
      ;; Process each descriptor group
      (SETQ LAST-GROUP-P (NULL (CDR DESC-GROUPS)))
      (DOLIST (DESC (CONSTRAINT-FRAME-SUBSTITUTION (CAR DESC-GROUPS)))

        REPARSE                                 ;Yes, this is a GO tag!

        ;; For each descriptor, parse it
        (SETQ DESC (CONSTRAINT-FRAME-SUBSTITUTION DESC))
        (LET ((NAME (CAR DESC))
              (WOS) (AENTRY) (MACRO-P))
          (OR (SETQ WOS (CDR (SETQ AENTRY (ASSQ NAME INTERNAL-ORDERING))))
              (FERROR "~A is unspecified in the ordering" NAME))
          (COND ((TYPEP WOS 'SHEET)
                 ;; A window -- parse the constraint and make the node
                 (MULTIPLE-VALUE-BIND (CONSTR MIN MAX TEM)
                     (PARSE-CONSTRAINT (CDR DESC) PANES WOS LAST-GROUP-P EVEN-P)
                   (SETQ EVEN-P TEM)
                   (PUSH (MAKE-CONSTRAINT-NODE CONSTRAINT-NAME (GET-PNAME NAME)
                                               CONSTRAINT-TYPE ':WINDOW
                                               CONSTRAINT-CONSTRAINT CONSTR
                                               CONSTRAINT-DATA WOS
                                               CONSTRAINT-MIN MIN
                                               CONSTRAINT-MAX MAX)
                         INTERNAL-DESC-GROUP)))
                ((NOT (SYMBOLP WOS))
                 (FERROR "~A is not a valid special name at this point" NAME))
                ((MEMQ (SECOND DESC) '(:HORIZONTAL :VERTICAL))
                 (AND (EQ (SECOND DESC) STACKING)
                      (FERROR "Current stacking (~A) same as new stacking" STACKING))
                 (MULTIPLE-VALUE-BIND (CONSTR MIN MAX TEM)
                     (PARSE-CONSTRAINT (THIRD DESC) PANES NIL LAST-GROUP-P EVEN-P)
                   (SETQ EVEN-P TEM)
                   (PUSH (MAKE-CONSTRAINT-NODE
                           CONSTRAINT-NAME (GET-PNAME NAME)
                           CONSTRAINT-TYPE ':STACKING
                           CONSTRAINT-CONSTRAINT CONSTR
                           CONSTRAINT-DATA
                            (CONSTRAINT-FRAME-PARSE-CONSTRAINTS (CDDDR DESC)
                                                                PANES
                                                                (SECOND DESC))
                           CONSTRAINT-MIN MIN
                           CONSTRAINT-MAX MAX)
                         INTERNAL-DESC-GROUP)))
                ((EQ (SECOND DESC) ':IF)
                 (FERROR "Conditionals not currently supported"))
                ((EQ (SECOND DESC) ':BLANK)
                 (MULTIPLE-VALUE-BIND (CONSTR MIN MAX TEM)
                     (PARSE-CONSTRAINT (CDDDR DESC) PANES NIL LAST-GROUP-P EVEN-P)
                   (SETQ EVEN-P TEM)
                   (PUSH (MAKE-CONSTRAINT-NODE
                           CONSTRAINT-NAME (GET-PNAME NAME)
                           CONSTRAINT-TYPE ':BLANK
                           CONSTRAINT-CONSTRAINT CONSTR
                           CONSTRAINT-DATA (CASE (THIRD DESC)
                                             (:WHITE #'CONSTRAINT-FRAME-WHITE-BLANKING)
                                             (:BLACK #'CONSTRAINT-FRAME-BLACK-BLANKING)
                                             (OTHERWISE (THIRD DESC)))
                           CONSTRAINT-MIN MIN
                           CONSTRAINT-MAX MAX)
                         INTERNAL-DESC-GROUP)))
                ((SETQ MACRO-P (GET (SECOND DESC) 'CONSTRAINT-MACRO))
                 ;; A macro: expand it and use its expansion in place of the current
                 ;; description
                 (SETQ DESC (CONS (CAR DESC) (FUNCALL MACRO-P DESC STACKING)))
                 (GO REPARSE))
                (T (FERROR "~A is unknown special keyword, perhaps ~A is missing from TV:PANES"
                           (SECOND DESC) (FIRST DESC))))
          (RPLACD AENTRY (CAR INTERNAL-DESC-GROUP))))
      (PUSH (NREVERSE INTERNAL-DESC-GROUP) INTERNAL-DESCS))
    (DOLIST (ORD INTERNAL-ORDERING)
      (AND (OR (TYPEP (CDR ORD) 'SHEET) (EQ (CAR ORD) (CDR ORD)))
           (FERROR "~A was specified in ordering, but not specified in any descriptor"
                   (CAR ORD))))
    (CONS INTERNAL-ORDERING (NREVERSE INTERNAL-DESCS))))

(DEFUNP PARSE-CONSTRAINT (CONSTR PANES WINDOW LG-P EVEN-P &AUX (MIN -1) (MAX 1_15.))
  "Verify correctness of the specified constraint.  Returns the constraint part
of the constraint, as well as the limits if specified."
  (COND ((EQ (FIRST CONSTR) ':LIMIT)
         (LET ((LIMITS (SECOND CONSTR))
               (ROUND) (OFFSET))
           (COND ((> (LENGTH LIMITS) 2)
                  (OR (SETQ WINDOW (OR (PARSE-CONSTRAINT-GET-PANE (FOURTH LIMITS) PANES)
                                       WINDOW))
                      (FERROR "Illegal format :LIMIT (no window specified)"))
                  (CASE (THIRD LIMITS)
                    (:CHARACTERS (SETQ ROUND (SHEET-CHAR-WIDTH WINDOW)
                                       OFFSET (+ (SHEET-LEFT-MARGIN-SIZE WINDOW)
                                                 (SHEET-RIGHT-MARGIN-SIZE WINDOW))))
                    (:LINES (SETQ ROUND (SHEET-LINE-HEIGHT WINDOW)
                                  OFFSET (+ (SHEET-TOP-MARGIN-SIZE WINDOW)
                                            (SHEET-BOTTOM-MARGIN-SIZE WINDOW))))
                    (OTHERWISE (FERROR "~A is illegal rounding specification"
                                       (THIRD LIMITS))))))
           (SETQ MIN (OR (FIRST LIMITS) MIN)
                 MAX (OR (SECOND LIMITS) MAX))
           (SETQ MIN (IF ROUND (+ (* MIN ROUND) OFFSET) MIN)
                 MAX (IF ROUND (+ (* MAX ROUND) OFFSET) MAX)))
         (SETQ CONSTR (CDDR CONSTR))))
  (COND ((OR (IF (NUMBERP (FIRST CONSTR))
                 (OR (NULL EVEN-P) (EQ EVEN-P ':NO)
                     (FERROR "Cannot mix :EVEN constraints and other constraints"))
                 NIL)
             (COND ((EQ (FIRST CONSTR) ':EVEN)
                    (OR LG-P (FERROR ":EVEN not in last descriptor group"))
;;; This was causing incredible problems... looks useless -dg
;                   (OR (NULL EVEN-P) (EQ EVEN-P ':YES)
;                       (FERROR "Cannot mix :EVEN constraints and other constraints"))
                    (SETQ EVEN-P ':YES)
                    T)))
         (COND ((> (LENGTH CONSTR) 1)
                (LET ((W (PARSE-CONSTRAINT-GET-PANE (THIRD CONSTR) PANES)))
                  (IF W
                      (SETQ WINDOW W
                            CONSTR (LIST (FIRST CONSTR) (SECOND CONSTR) W))
                      (OR WINDOW
                          (FERROR "Illegal format constraint -- no window specified"))))
                (OR (MEMQ (SECOND CONSTR) '(:LINES :CHARACTERS))
                    (FERROR "Illegal rounding specifier ~A" (SECOND CONSTR)))
                (AND (FIXP (FIRST CONSTR))
                     (SETQ CONSTR (LIST (* (FIRST CONSTR)
                                           (CASE (SECOND CONSTR)
                                             (:LINES (SHEET-LINE-HEIGHT WINDOW))
                                             (:CHARACTERS (SHEET-CHAR-WIDTH WINDOW))))
                                        (SECOND CONSTR)
                                        WINDOW))))))
        ((NOT (OR (NULL EVEN-P) (EQ EVEN-P ':NO)))
         (FERROR "Cannot mix :EVEN constraints and other constraints"))
        ((MEMQ (FIRST CONSTR) '(:ASK :FUNCALL :EVAL :FIXED)))
        ((EQ (FIRST CONSTR) ':ASK-WINDOW)
         (LET ((W (IF (EQ (SECOND CONSTR) 'SELF)
                      SELF
                      (CDR (ASSQ (SECOND CONSTR) PANES)))))
           (OR W (FERROR "Unknown pane ~A is :ASK-WINDOW constraint"
                         (SECOND CONSTR)))
           (SETF (SECOND (SETQ CONSTR (COPYLIST CONSTR))) W))))
  (RETURN (VALUES CONSTR MIN MAX (OR EVEN-P ':NO))))

(DEFUN PARSE-CONSTRAINT-GET-PANE (PANE-NAME PANES)
  (AND PANE-NAME
       (OR (CDR (ASSQ PANE-NAME PANES))
           (FERROR "Unknown pane name ~A" PANE-NAME))))

(DEFUN CONSTRAINT-FRAME-DO-CONSTRAINTS (FRAME CONSTRS
                                        &OPTIONAL (W (SHEET-INSIDE-WIDTH FRAME))
                                                  (H (SHEET-INSIDE-HEIGHT FRAME)))
  (CATCH ':VERTICAL
    (CATCH ':HORIZONTAL
      (PROGN
        (CONSTRAINT-FRAME-DO-SIZES W H CONSTRS)
        (SEND FRAME :SET-EXPOSED-PANES
                    (CONSTRAINT-FRAME-DO-POSITIONS CONSTRS CONSTRAINT-FRAME-DEFAULT-STACKING
                                                   (SHEET-LEFT-MARGIN-SIZE FRAME)
                                                   (SHEET-TOP-MARGIN-SIZE FRAME)))
        T))))

(DEFUN CONSTRAINT-FRAME-DO-SIZES (WIDTH HEIGHT CONSTRS
                                   &OPTIONAL (STACKING CONSTRAINT-FRAME-DEFAULT-STACKING))
  "Given that the current width and height of the frame, calculate new values of position
and size for each node.  Constraints are assumed parsed and valid."
;;; **** Does not know about min's or max's yet!
  (LET ((DESC-GROUPS (CDR CONSTRS)))
    (DOLIST (DESC-GROUP DESC-GROUPS)
      ;; For each group, assign widths and heights
      (LET (WIDTH-USED HEIGHT-USED)
        (COND ((NOT (CATCH STACKING
                      (PROGN
                        (MULTIPLE-VALUE (WIDTH-USED HEIGHT-USED)
                          (CONSTRAINT-FRAME-DO-SIZES-INTERNAL DESC-GROUP
                                                              WIDTH HEIGHT WIDTH HEIGHT
                                                              STACKING))
                        T)))
               ;; Some constraint couldn't be satisfied.  Try only allowing each constraint
               ;; to take 1/Nth of the area, where N is the total number of constraints
               (MULTIPLE-VALUE (WIDTH-USED HEIGHT-USED)
                 (CONSTRAINT-FRAME-DO-SIZES-INTERNAL DESC-GROUP WIDTH HEIGHT
                   (IF (EQ STACKING ':HORIZONTAL) (TRUNCATE WIDTH (LENGTH DESC-GROUP)) WIDTH)
                   (IF (EQ STACKING ':VERTICAL) (TRUNCATE HEIGHT (LENGTH DESC-GROUP)) HEIGHT)
                   STACKING))))
        (SETQ WIDTH (- WIDTH WIDTH-USED)
              HEIGHT (- HEIGHT HEIGHT-USED))
        (AND (OR (< WIDTH 0) (< HEIGHT 0))
             (THROW STACKING NIL))))))

(DEFUN CONSTRAINT-FRAME-DO-SIZES-INTERNAL (DESC-GROUP WIDTH HEIGHT AV-WIDTH AV-HEIGHT STACKING
                                           &AUX (WIDTH-USED 0) (HEIGHT-USED 0) W H)
  (DOLIST (NODE DESC-GROUP)
    ;; Amount of room available is the smaller of the total amount of room, or the maximum
    ;; allowed by the caller
    (SETQ AV-WIDTH (MIN (- WIDTH WIDTH-USED) AV-WIDTH)
          AV-HEIGHT (MIN (- HEIGHT HEIGHT-USED) AV-HEIGHT))
    (CASE (CONSTRAINT-TYPE NODE)
      ;; Dispatch on node type
      ((:WINDOW :BLANK)
       ;; A real window, easy -- compute the new values, stick 'em in, and loop
       ;; Blanks get handled in same way
       (MULTIPLE-VALUE (W H)
         (CONSTRAINT-FRAME-DO-A-CONSTRAINT NODE AV-WIDTH AV-HEIGHT WIDTH HEIGHT
                                           STACKING DESC-GROUP)))
      (:STACKING
       ;; A special thing, some sort of descent needed.  First fill in size
       (MULTIPLE-VALUE (W H)
         (CONSTRAINT-FRAME-DO-A-CONSTRAINT NODE AV-WIDTH AV-HEIGHT WIDTH HEIGHT
                                           STACKING DESC-GROUP))
       ;; Then recurse with new values
       (CONSTRAINT-FRAME-DO-SIZES W H (CONSTRAINT-DATA NODE)
                                  (CASE STACKING
                                    (:VERTICAL ':HORIZONTAL)
                                    (:HORIZONTAL ':VERTICAL))))
      (:IF (FERROR ":IF not yet supported"))
      (OTHERWISE (FERROR "Unknown node type ~A" (CONSTRAINT-TYPE NODE))))
    (CASE STACKING
      (:VERTICAL
       (SETQ HEIGHT-USED (+ HEIGHT-USED H))
       (AND (> HEIGHT-USED HEIGHT)
            ;; Ran out of room, try alternate algorithm
            (THROW ':VERTICAL NIL)))
      (:HORIZONTAL
       (SETQ WIDTH-USED (+ WIDTH-USED W))
       (AND (> WIDTH-USED WIDTH)
            (THROW ':HORIZONTAL NIL)))))
  (VALUES WIDTH-USED HEIGHT-USED))


(DEFVAR **CONSTRAINT-NODE**)
(DEFVAR **CONSTRAINT-REMAINING-WIDTH**)
(DEFVAR **CONSTRAINT-REMAINING-HEIGHT**)
(DEFVAR **CONSTRAINT-TOTAL-WIDTH**)
(DEFVAR **CONSTRAINT-TOTAL-HEIGHT**)
(DEFVAR **CONSTRAINT-CURRENT-STACKING**)

(DEFUNP CONSTRAINT-FRAME-DO-A-CONSTRAINT (NODE AV-W AV-H W H STACKING DG &AUX AMOUNT CON)
  "Processes one constraint, setting the proposed width and height in the node to the
ones specified by the constraint."
  (SETQ CON (CONSTRAINT-CONSTRAINT NODE))
  (COND
    ;; Dispatch on type of constraint
    ((EQ (FIRST CON) ':ASK-WINDOW)
     (SETQ AMOUNT (MIN (CONSTRAINT-MAX NODE)
                       (MAX (CONSTRAINT-MIN NODE)
                            (LEXPR-SEND (SECOND CON) (THIRD CON)
                                           AV-W AV-H W H STACKING (CDDDR CON))))))
    ((EQ (FIRST CON) ':ASK)
     (SETQ AMOUNT (MIN (CONSTRAINT-MAX NODE)
                       (MAX (CONSTRAINT-MIN NODE)
                            (LEXPR-SEND (CONSTRAINT-DATA NODE)
                                        (SECOND CON) AV-W AV-H W H STACKING (CDDR CON))))))
    ((EQ (FIRST CON) ':FUNCALL)
     (SETQ AMOUNT (MIN (CONSTRAINT-MAX NODE)
                       (MAX (CONSTRAINT-MIN NODE)
                            (APPLY (SECOND CON) NODE AV-W AV-H W H STACKING
                                   (CDDR CON))))))
    ((EQ (FIRST CON) ':EVAL)
     (LET ((**CONSTRAINT-NODE** NODE)
           (**CONSTRAINT-REMAINING-WIDTH** AV-W)
           (**CONSTRAINT-REMAINING-HEIGHT** AV-H)
           (**CONSTRAINT-TOTAL-WIDTH** W)
           (**CONSTRAINT-TOTAL-HEIGHT** H)
           (**CONSTRAINT-CURRENT-STACKING** STACKING))
       (SETQ AMOUNT (MIN (CONSTRAINT-MAX NODE)
                       (MAX (CONSTRAINT-MIN NODE)
                            (EVAL (SECOND CON)))))))
    ((FIXP (FIRST CON))
     (SETQ AMOUNT (CONSTRAINT-ROUND (FIRST CON) CON NODE)))
    ((FLOATP (FIRST CON))
     (SETQ AMOUNT (CONSTRAINT-ROUND (* (FIRST CON) (CASE STACKING
                                                     (:VERTICAL H)
                                                     (:HORIZONTAL W)))
                                    CON NODE)))
    ((EQ (FIRST CON) ':EVEN)
     (SETQ AMOUNT (CONSTRAINT-ROUND (TRUNCATE (CASE STACKING
                                                (:HORIZONTAL AV-W)
                                                (:VERTICAL AV-H))
                                              (- (LENGTH DG)
                                                 (DO ((I 0 (1+ I))
                                                      (L DG (CDR L)))
                                                     ((NULL L) (FERROR "Node not a node"))
                                                   (AND (EQ (CAR L) NODE) (RETURN I)))))
                                    CON NODE)))
    ((EQ (FIRST CON) ':FIXED)
     (CASE STACKING
       (:VERTICAL (SETQ AMOUNT (SHEET-HEIGHT (CONSTRAINT-DATA NODE))
                        W (SHEET-WIDTH (CONSTRAINT-DATA NODE))))
       (:HORIZONTAL (SETQ H (SHEET-HEIGHT (CONSTRAINT-DATA NODE))
                          AMOUNT (SHEET-WIDTH (CONSTRAINT-DATA NODE))))))
    (T (FERROR "Unknown constraint type ~A" CON)))
  (CASE STACKING
    (:VERTICAL (SETF (CONSTRAINT-PW NODE) W)
               (SETF (CONSTRAINT-PH NODE) (SETQ H AMOUNT)))
    (:HORIZONTAL (SETF (CONSTRAINT-PW NODE) (SETQ W AMOUNT))
                 (SETF (CONSTRAINT-PH NODE) H))
    (OTHERWISE (FERROR "Illegal value for stacking ~A" STACKING)))
  (RETURN (VALUES W H)))

(DEFUN CONSTRAINT-ROUND (SIZE CON NODE &AUX TEM (WINDOW (CONSTRAINT-DATA NODE)))
  "Given a proposed size, a constraint, and the node, don't round, or round to lines
or characters.  Also enforces limits."
  (SETQ SIZE (FIX SIZE))
  (MIN (CONSTRAINT-MAX NODE)
       (MAX (CONSTRAINT-MIN NODE)
            (COND ((OR (NUMBERP (FIRST CON)) (EQ (FIRST CON) ':EVEN))
                   (SETQ WINDOW (OR (THIRD CON) WINDOW))
                   (CASE (SECOND CON)
                     (:LINES
                      (+ (SHEET-TOP-MARGIN-SIZE WINDOW) (SHEET-BOTTOM-MARGIN-SIZE WINDOW)
                         (* (SETQ TEM (SHEET-LINE-HEIGHT WINDOW))
                            (TRUNCATE SIZE TEM))))
                     (:CHARACTERS
                      (+ (SHEET-LEFT-MARGIN-SIZE WINDOW) (SHEET-RIGHT-MARGIN-SIZE WINDOW)
                         (* (SETQ TEM (SHEET-CHAR-WIDTH WINDOW))
                            (TRUNCATE SIZE TEM))))
                     (T SIZE)))
                  (T SIZE)))))

(DEFUN CONSTRAINT-FRAME-DO-POSITIONS (CONSTRS
                                       &OPTIONAL (STACKING CONSTRAINT-FRAME-DEFAULT-STACKING)
                                                 (X 0) (Y 0)
                                       &AUX NODE PANES)
  "Given that proposed size has been set up, set up the proposed positions.  Returns a list
of all involved panes."
  (DOLIST (AENTRY (FIRST CONSTRS))
    ;; Loop over windows in order, and assign positions
    (SETQ NODE (CDR AENTRY))
    (SETF (CONSTRAINT-PX NODE) X)
    (SETF (CONSTRAINT-PY NODE) Y)
    (CASE (CONSTRAINT-TYPE NODE)
      (:WINDOW (PUSH (CONSTRAINT-DATA NODE) PANES))
      (:STACKING (SETQ PANES
                       (NCONC (CONSTRAINT-FRAME-DO-POSITIONS (CONSTRAINT-DATA NODE)
                                                             (CASE STACKING
                                                               (:VERTICAL ':HORIZONTAL)
                                                               (:HORIZONTAL ':VERTICAL))
                                                             X Y)
                              PANES)))
      (:IF (FERROR ":IF not yet supported"))
      (:BLANK)
      (OTHERWISE (FERROR "Unknown node type ~A" (CONSTRAINT-TYPE NODE))))
    (CASE STACKING
      (:VERTICAL (SETQ Y (+ Y (CONSTRAINT-PH NODE))))
      (:HORIZONTAL (SETQ X (+ X (CONSTRAINT-PW NODE))))))
  PANES)

(DEFUN CONSTRAINT-FRAME-WHITE-BLANKING (IGNORE X Y W H ARRAY)
  (DECLARE (:SELF-FLAVOR SHEET))
  (BITBLT ERASE-ALUF W H BLANKING-ARRAY 0 0 ARRAY X Y))

(DEFUN CONSTRAINT-FRAME-BLACK-BLANKING (IGNORE X Y W H ARRAY)
  (DECLARE (:SELF-FLAVOR SHEET))
  (BITBLT CHAR-ALUF W H BLANKING-ARRAY 0 0 ARRAY X Y))

(DEFUN CONSTRAINT-FRAME-STIPPLE-BLANKING (IGNORE X Y W H ARRAY GRAY-ARRAY)
  (DECLARE (:SELF-FLAVOR SHEET))
  (BITBLT CHAR-ALUF W H
          GRAY-ARRAY (\ X (PIXEL-ARRAY-WIDTH GRAY-ARRAY))
                     (\ Y (PIXEL-ARRAY-HEIGHT GRAY-ARRAY))
          ARRAY X Y))

(DEFUN CONSTRAINT-FRAME-DRAW-A-BLANK (BLANK-TYPE NODE X Y W H SCREEN-ARRAY)
  "Draw blanking of type BLANK-TYPE for constraint node NODE.
We blank a rectangle of size W, H with upper left corner at X, Y.
The drawing is done in SCREEN-ARRAY.
BLANK-TYPE is either a function (which receives the rest of our args),
a list of a function and some additional args to give it,
or an array of stipple pattern to BITBLT from."
  (COND ((FUNCTIONP BLANK-TYPE)
         ;; An explicit drawing function
         (FUNCALL BLANK-TYPE NODE X Y W H SCREEN-ARRAY))
        ((CONSP BLANK-TYPE)
         (APPLY (CAR BLANK-TYPE) NODE X Y W H SCREEN-ARRAY (CDR BLANK-TYPE)))
        ((ARRAYP BLANK-TYPE)
         ;; Stipple array -- draw in standard way
         (CONSTRAINT-FRAME-STIPPLE-BLANKING NODE X Y W H SCREEN-ARRAY BLANK-TYPE))
        (T (FERROR "~S is an unknown type of blanking" BLANK-TYPE))))

(DEFVAR BLANKING-ARRAY (MAKE-PIXEL-ARRAY 32. 1 :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 1))


;;; Constraint macros

(DEFUN (FIXED-WITH-WHITESPACE CONSTRAINT-MACRO) (OLD-DESC STACKING)
  "A constraint-frame macro to take a window, and giving it the :FIXED attribute
leave whitespace around it on all four sides.  Format is:
    (name FIXED-WITH-WHITESPACE name-of-window color-of-border . constraint)
"
  (LET ((SYM1 (GENSYM)) (SYM2 (GENSYM)) (SYM3 (GENSYM)) (SYM4 (GENSYM))
        (SN (GENSYM)) (COB (FOURTH OLD-DESC)))
    `(,(CASE STACKING
         (:VERTICAL ':HORIZONTAL)
         (:HORIZONTAL ':VERTICAL))
      ,(CDDDDR OLD-DESC)
      (,SYM1 ,SN ,SYM2)
      ((,SN ,STACKING (:ASK-WINDOW ,(THIRD OLD-DESC) :PANE-SIZE)
        (,SYM3 ,(THIRD OLD-DESC) ,SYM4)
        ((,(THIRD OLD-DESC) :FIXED))
        ((,SYM3 :BLANK ,COB :EVEN) (,SYM4 :BLANK ,COB :EVEN))))
      ((,SYM1 :BLANK ,COB :EVEN) (,SYM2 :BLANK ,COB :EVEN)))))

(DEFUN (INTERDIGITATED-WHITESPACE CONSTRAINT-MACRO) (OLD-DESC STACKING)
  "Leave whitespace betweem all specified constraints (alternates stacking):
    (name INTERDIGITATED-WHITESPACE color :INCLUDE-or-:EXCLUDE
          our-constraint
          whitespace-constraint
          . <same as args to a stacking constraint>)

   :EXCLUDE means no whitespace before first and after last, :INCLUDE means include this
whitespace."
  (LET ((COLOR (THIRD OLD-DESC))
        (IOE (FOURTH OLD-DESC))
        (WSPACECON (SIXTH OLD-DESC))
        (INFS (SEVENTH OLD-DESC))
        (WSPACE) (NINFS))
    (OR (MEMQ IOE '(:INCLUDE :EXCLUDE))
        (FERROR "~A must be either :INCLUDE or :EXCLUDE" IOE))
    (DO ((I INFS (CDR I))
         (GS))
        (NIL)
      (COND ((AND (EQ IOE ':EXCLUDE)
                  (OR (EQ I INFS) (NULL I))))
            (T
             (SETQ GS (GENSYM))
             (PUSH GS NINFS)
             (PUSH `(,GS :BLANK ,COLOR . ,WSPACECON) WSPACE)))
      (AND I (PUSH (CAR I) NINFS))
      (AND (NULL I) (RETURN)))
    `(,(CASE STACKING
         (:VERTICAL ':HORIZONTAL)
         (:HORIZONTAL ':VERTICAL))
      ,(FIFTH OLD-DESC)
      ,(NREVERSE NINFS)
      . ,(LET ((CONSTRS (COPYLIST (NTHCDR 7 OLD-DESC))))
           (DO ((CS CONSTRS (CDR CS))
                (SEEN-* NIL))
               ((NULL CS)
                (OR SEEN-* (RPLACD (LAST CONSTRS) (NCONS WSPACE))))
             (COND ((MEMQ '* (CAR CS))
                    (SETQ SEEN-* T)
                    (RPLACA CS (APPEND (REMQ '* (CAR CS)) WSPACE)))))
           CONSTRS))))

;;; Support from other flavors

(DEFMETHOD (BASIC-MENU :PANE-SIZE) (REM-WIDTH REM-HEIGHT IGNORE IGNORE STACKING
                                              &OPTIONAL N-ROWS N-COLUMNS)
  (MULTIPLE-VALUE-BIND (IGNORE IGNORE NEW-WIDTH NEW-HEIGHT)
      (MENU-DEDUCE-PARAMETERS N-COLUMNS N-ROWS
                              (IF (EQ STACKING ':VERTICAL)
                                  (- REM-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)
                                  ':UNCONSTRAINED)
                              (IF (EQ STACKING ':HORIZONTAL)
                                  (- REM-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE)
                                  ':UNCONSTRAINED)
                              (- REM-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)
                              (- REM-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
    (CASE STACKING
      (:VERTICAL (+ NEW-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
      (:HORIZONTAL (+ NEW-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)))))

(DEFMETHOD (ESSENTIAL-WINDOW :PANE-SIZE) (REM-WIDTH REM-HEIGHT IGNORE IGNORE STACKING)
  (CASE STACKING
    (:VERTICAL (MIN REM-HEIGHT HEIGHT))
    (:HORIZONTAL (MIN REM-WIDTH WIDTH))))

(COMPILE-FLAVOR-METHODS BASIC-FRAME
                        CONSTRAINT-FRAME-NO-FORWARDING
                        CONSTRAINT-FRAME BORDERED-CONSTRAINT-FRAME
                        CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER
                        BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER)
